/* -*-mode:c; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*- */
#include <stdlib.h>
#include <stdio.h>
#include <string.h>
#include <math.h>
#include "misc.h"
#include "gen_read.h"
#include "token.h"
#include "parse_tree.h"

// Stack of infotainment strings.  Top level string is displayed
// If readline is the input source.
typedef struct _NEST_INFO {
  char *info;
  struct _NEST_INFO *prev;
} NEST_INFO;

// This  is basically  used to  store the  next token  of lookahead.   The input
// character  stream  is packaged  up  with  the  token  since they  are  always
// associated with one another.
typedef struct {
  GEN_READ *input_src;
  TOKEN tk;
  // nesting is used to indicate if some more tokens are expected.
  // For example
  //                  1   +   2   *   (   3   -   4   )
  // nestlevel            0  0   1   0   1 2  2  2   3   2 1 0
  //
  // If more tokens are expected, then a NEWLINE is treated as
  // whitespace, otherwise it is interpreted as (end of input)/evaluate
  // by a repl or reader.
  NEST_INFO *nest_tos;
} TOKEN_SOURCE;

typedef PTREE_NODE *(PARSE_FN)(TOKEN_SOURCE *, ERR_INFO *);

static void tsrc_init(TOKEN_SOURCE *tsrc, GEN_READ *r);
static int tsrc_next(TOKEN_SOURCE *tsrc);
static PTREE_NODE *ptree_alloc(int type);
static int lst_test(TOKEN_SOURCE *tsrc, int tk, int tkgrp);
static void op_lst_free(PTREE_NODE_OP_LST *lst);
static PTREE_NODE_OP_LST *get_op_lst(TOKEN_SOURCE *tsrc, ERR_INFO *err,
                                     int tk, int tkgrp, PARSE_FN prsfn);
static void ptree_seq_to_gviz_aux(PTREE_NODE_OP_LST *seq_nd, FILE *fout);
static void ptree_to_gviz_aux(PTREE_NODE *ptree, FILE *fout);
static PTREE_NODE *seq_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *expr(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *if_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *tuple_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *tuple_component(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *factor(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *data_constructor(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *application(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *closure(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *pattern_alternative(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *pattern(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *tuple_pattern_component(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *test(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *var_ref(TOKEN_SOURCE *tsrc, ERR_INFO *err);
static PTREE_NODE *anonymous_var(TOKEN_SOURCE *tsrc, ERR_INFO *err);
PTREE_NODE *get_symbol_or_data_cons(TOKEN_SOURCE *tsrc, ERR_INFO *err,
                                    char *name, int pattern);

char *prompt = "-->";

static void tsrc_init(TOKEN_SOURCE *tsrc, GEN_READ *r)
{
  tk_init(&tsrc->tk);
  tsrc->input_src = r;
  tsrc->nest_tos = NULL;
}

static void push_nest_info(TOKEN_SOURCE *tsrc, char *info)
{
  NEST_INFO *nst;
  // fflush(stdout);
  if (!(nst = malloc(sizeof(NEST_INFO)))) {
    fprintf(stderr, "memory overflow\n");
    exit(0);
  }
  nst->info = strdup(info);
  nst->prev = tsrc->nest_tos;
  tsrc->nest_tos = nst;
}

static void pop_nest_info(TOKEN_SOURCE *tsrc)
{
  NEST_INFO *tmp;
  if (tsrc->nest_tos) {
    free(tsrc->nest_tos->info);
    tmp = tsrc->nest_tos;
    tsrc->nest_tos = tsrc->nest_tos->prev;
    free(tmp);
  }
}

static int tsrc_next(TOKEN_SOURCE *tsrc)
{
  tk_free(&tsrc->tk);
  tk_init(&tsrc->tk);
  if (tsrc->nest_tos) {
    char new_prompt[256];
    sprintf(new_prompt, "...(%s) :", tsrc->nest_tos->info);
    gr_set_prompt(tsrc->input_src, new_prompt);
    do {
      // empty
    } while (TK_NEWLINE == tk_next(tsrc->input_src, &tsrc->tk));
  } else {
    gr_set_prompt(tsrc->input_src, prompt);
    tk_next(tsrc->input_src, &tsrc->tk);
  }
  tk_print(&tsrc->tk);
  return tsrc->tk.type;
}

static PTREE_NODE *ptree_alloc(int type)
{
  PTREE_NODE *ptree = malloc(sizeof(PTREE_NODE));
  if (!ptree) {
    fprintf(stderr, "Memory exhausted.\n");
    exit(1);
  }
  ptree->type = type;
  return ptree;
}

void ptree_free(PTREE_NODE *ptree)
{
  //free(ptree);
  //TODO: recursive free here.
}

static void op_lst_free(PTREE_NODE_OP_LST *lst)
{
  //TODO: free stuff here.
}

static char *parse_err_msg(char *msg, TOKEN_SOURCE *tsrc) {
  char tk[MAX_STR], str[MAX_STR];
  tk_str(&tsrc->tk, tk, MAX_STR);
  snprintf(str, MAX_STR, "%s Token: %s.", msg, tk);
  return strdup(str);
}


PTREE_NODE *parse(GEN_READ *r, ERR_INFO *err)
{
  // SYNTAX:
  //   repl = (seqExpr nl)*
  TOKEN_SOURCE tsrc;
  PTREE_NODE *ptree = NULL;
  tsrc_init(&tsrc, r);
  err->msg = NULL;
  // Read in first token to get things started.
  do {
    tsrc_next(&tsrc);
  } while (TK_NEWLINE == tsrc.tk.type);
  if (TK_EOF != tsrc.tk.type) {
    if (ptree = seq_expr(&tsrc, err)) {
      if (TK_EOF != tsrc.tk.type && TK_NEWLINE != tsrc.tk.type) {
        err->msg = parse_err_msg("Unexpected token found on top level parse.",
                                 &tsrc);
        ptree_free(ptree);
        ptree = NULL;
      }
    }
  }
  return ptree;
}

static PTREE_NODE *seq_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX:
  //   seqExpr = expr (';' expr)*
  PTREE_NODE *result = ptree_alloc(PT_SEQ_EXPR);
   // replace: factor -> expr later
  if (!(result->expr0 = expr(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  // Assume no (';' expr)+ part
  result->rest_seq = get_op_lst(tsrc, err, TK_SEQ, 0, expr);
  return result;
}

static PTREE_NODE *expr(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   expr = ifExpr | tupleExpr
  PTREE_NODE *result = ptree_alloc(PT_EXPR);
  if (TK_IF == tsrc->tk.type) {
    if (!(result->expr = if_expr(tsrc, err))) {
      ptree_free(result);
      return NULL;
    }
  } else {
    if (!(result->expr = tuple_expr(tsrc, err))) {
      ptree_free(result);
      return NULL;
    }
  }
}

static PTREE_NODE *tuple_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX:
  //   tupleExpr = tupleComponent (',' tupleComponent)*
  PTREE_NODE *result = ptree_alloc(PT_TUPLE_EXPR);
  if (!(result->comp0 = tuple_component(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  result->rest_comp = get_op_lst(tsrc, err, TK_TUPLE_APPEND, 0, tuple_component);
  return result;
}

static PTREE_NODE *tuple_component(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX:
  //   tupleComponent = factor (operator factor)*
  PTREE_NODE *result = ptree_alloc(PT_TUPLE_COMPONENT);
  if (!(result->factor0 = factor(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  result->rest_factor = get_op_lst(tsrc, err, TK_NONE, TKGRP_INFIX | TKGRP_HIPRI,
                                   factor);
  return result;
}

static int lst_test(TOKEN_SOURCE *tsrc, int tk, int tkgrp)
{
  return (tk != TK_NONE && tk == tsrc->tk.type) ||
    (tkgrp != 0 && (tkgrp == (tsrc->tk.type & ~((1 << 7) - 1))));
}

static PTREE_NODE_OP_LST *get_op_lst(TOKEN_SOURCE *tsrc, ERR_INFO *err,
                                     int tk, int tkgrp, PARSE_FN prsfn)
{
  if (!lst_test(tsrc, tk, tkgrp)) {
    return NULL;
  } else {
    PTREE_NODE_OP_LST *lst_curr_nd, *lst_head;
    int lst_tk;
    if (!(lst_head = malloc(sizeof(PTREE_NODE_OP_LST)))) {
      fprintf(stderr, "memory overflow\n");
      exit(0);
    }
    lst_curr_nd = lst_head;
    while (lst_test(tsrc, tk, tkgrp)) {
      //printf("getting op list\n");
      lst_tk = tsrc->tk.type;
      // Input is *required* so nest
      //printf("pushing operator %s\n", tsrc->tk.name);
      push_nest_info(tsrc, tsrc->tk.name);
      tsrc_next(tsrc);
      // No input is *required* at this point
      pop_nest_info(tsrc);
      lst_curr_nd->next = NULL;
      lst_curr_nd->tk_op = lst_tk;
      if (!(lst_curr_nd->opnd = (*prsfn)(tsrc, err))) {
        op_lst_free(lst_head);
        return NULL;
      }
      // Will we need to add yet another node to the list?
      if (lst_test(tsrc, tk, tkgrp)) {
        if (!(lst_curr_nd->next = malloc(sizeof(PTREE_NODE_OP_LST)))) {
          fprintf(stderr, "memory overflow\n");
          exit(0);
        }
        lst_curr_nd = lst_curr_nd->next;
      }
    }
    return lst_head;
  }
}

static PTREE_NODE *if_expr(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   ifExpr = 'if' seqExpr 'then' seqExpr 'else' seqExpr
  PTREE_NODE *result;
  result = ptree_alloc(PT_IF_EXPR);
  // Current token == TK_IF
  // Input is *required* at this point.
  push_nest_info(tsrc, "then");
  tsrc_next(tsrc);
  if (!(result->test = tuple_expr(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  if (TK_THEN != tsrc->tk.type) {
    err->msg = parse_err_msg("Unexpected token following test in 'if'"
                             " expression.  Expected 'then'.", tsrc);
    ptree_free(result);
    return NULL;
  }
  // Skip 'then'
  pop_nest_info(tsrc);
  push_nest_info(tsrc, "else");
  tsrc_next(tsrc);
  if (!(result->then_part = tuple_expr(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  if (TK_ELSE != tsrc->tk.type) {
    err->msg = parse_err_msg("Unexpected token following then_part in 'if'"
                             " expression.  Expected 'else'.", tsrc);
    ptree_free(result);
    return NULL;
  }
  // Skip 'else'
  tsrc_next(tsrc);
  // Input is no longer required to complete parse
  pop_nest_info(tsrc);
  if (!(result->else_part = tuple_expr(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  return result;
}

static PTREE_NODE *tuple_pattern_component(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   tuplepatterncomponent = number                 |
  //                           symbol                 |
  //                           patternDataConstructor |
  //                           test                   |
  //                           varRef                 |
  //                           patternVar             |
  //                           anonymousVar
  //   test                  = varName '(' pattern ')'
  //   varRef                = 'ref' varName
  //   patternVar            = varName
  //   anonymousVar          = '_'
  PTREE_NODE *result = ptree_alloc(PT_TUPLE_PATTERN_COMPONENT);
  //tk_print(&tsrc->tk);
  switch (tsrc->tk.type) {
    case TK_ANONYMOUS_VAR:
      result->tup_pat_cmp = ptree_alloc(PT_ANONYMOUS_VAR);
      tsrc_next(tsrc);
      return result;
      break;
    case TK_VARNAME: {
      char *name = strdup(tsrc->tk.name);
      tsrc_next(tsrc);
      if (TK_L_ROUND_BRACK == tsrc->tk.type) {
        result->tup_pat_cmp = ptree_alloc(PT_TEST);
        result->tup_pat_cmp->test_name = name;
        // Skip '('
        push_nest_info(tsrc, ")");
        tsrc_next(tsrc);
        if (TK_R_ROUND_BRACK == tsrc->tk.type) {
          // name()
          result->tup_pat_cmp->test_pat = NULL;
          pop_nest_info(tsrc);
          // Skip ')'
          tsrc_next(tsrc);
        } else {
          // name(stuff...)
          if (!(result->tup_pat_cmp->test_pat = pattern(tsrc, err))) {
            ptree_free(result);
            return NULL;
          }
          if (TK_R_ROUND_BRACK != tsrc->tk.type) {
            err->msg = parse_err_msg("Expected '(' for tuplePatternComponent",
                                     tsrc);
            ptree_free(result);
          }
          pop_nest_info(tsrc);
          // skip ')'
          tsrc_next(tsrc);
        }
      } else {
        result->tup_pat_cmp = ptree_alloc(PT_PATTERN_VAR);
        result->tup_pat_cmp->pat_var = name;
      }
      return result;
      break;
    }
    case TK_NUMBER:
      result->tup_pat_cmp = ptree_alloc(PT_NUMBER);
      result->tup_pat_cmp->num = tsrc->tk.num;
      tsrc_next(tsrc);
      return result;
      break;
    case TK_SYMBOL: {
      char *name = strdup(tsrc->tk.name);
      tsrc_next(tsrc);
      if (!(result->tup_pat_cmp = get_symbol_or_data_cons(tsrc, err, name, 1))) {
        ptree_free(result);
        return NULL;
      }
      return result;
      break;
    }
    case TK_REF:
      // skip 'ref'
      push_nest_info(tsrc, "var");
      tsrc_next(tsrc);
      if (TK_VARNAME != tsrc->tk.type) {
        err->msg = parse_err_msg("Expected variable to follow 'ref'.", tsrc);
        return NULL;
      }
      result->tup_pat_cmp = ptree_alloc(PT_VAR_REF);
      result->tup_pat_cmp->ref_var = strdup(tsrc->tk.name);
      // skip varname
      pop_nest_info(tsrc);
      tsrc_next(tsrc);
      return result;
      break;
    default:
      err->msg = parse_err_msg("Unknown token found for tuple pattern component.",
                               tsrc);
      ptree_free(result);
      return NULL;
      break;
  }
}

static PTREE_NODE *pattern(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   pattern = tuplePatternComponent (',' tuplePatternComponent)*
  PTREE_NODE *result = ptree_alloc(PT_PATTERN);
  if (!(result->tup_pat_cmp0 = tuple_pattern_component(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  result->rest_tup_pat_cmp = get_op_lst(tsrc, err, TK_TUPLE_APPEND, 0,
                                        tuple_pattern_component);
  return result;
}

static PTREE_NODE *pattern_alternative(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   patternAlternative = [pattern] '->' seqExpr
  PTREE_NODE *result = ptree_alloc(PT_PATTERN_ALTERNATIVE);
  if (TK_RIGHT_ARROW == tsrc->tk.type) {
    // Empty pattern.
    result->pat = NULL;
  } else {
    push_nest_info(tsrc, "->");
    if (!(result->pat = pattern(tsrc, err))) {
      ptree_free(result);
      return NULL;
    }
    pop_nest_info(tsrc);
  }
  // This handles both cases above. (always true for the first case)
  if (TK_RIGHT_ARROW != tsrc->tk.type) {
    err->msg = parse_err_msg("Expected '->' in pattern alternative.", tsrc);
    ptree_free(result);
    return NULL;
  }
  push_nest_info(tsrc, "'|' or '}'");
  // Skip '->'
  tsrc_next(tsrc);
  if (!(result->result_seq_expr = seq_expr(tsrc, err))) {
    ptree_free(result);
    return NULL;
  }
  pop_nest_info(tsrc);
  // Current token needs to be interpreted by caller so don't skip over it.
  // It could be '|' or '}'
  return result;
}

static PTREE_NODE *closure(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   closure = '{' [patternAlternative ( '|' patternAlternative )*] '}'
  PTREE_NODE *result = ptree_alloc(PT_CLOSURE);
  push_nest_info(tsrc, "}");
  // Skip '{'
  tsrc_next(tsrc);
  if (TK_R_CLOSURE_BRACK == tsrc->tk.type) {
    // Empty closure .. always returns ()
    result->pat_alt0 = NULL;
    result->rest_pat_alts = NULL;
  } else {
    if (!(result->pat_alt0 = pattern_alternative(tsrc, err))) {
      ptree_free(result);
      return NULL;
    }
    result->rest_pat_alts = get_op_lst(tsrc, err, TK_PATTERN_ALT, 0,
                                       pattern_alternative);
  }
  // This handles both cases above.  Always true for first case.
  if (TK_R_CLOSURE_BRACK != tsrc->tk.type) {
    err->msg = parse_err_msg("Missing closing '}'.", tsrc);
    ptree_free(result);
    return NULL;
  }
  pop_nest_info(tsrc);
  // Skip '}'
  tsrc_next(tsrc);
  return result;
}

PTREE_NODE *get_symbol_or_data_cons(TOKEN_SOURCE *tsrc, ERR_INFO *err,
                                    char *name, int in_pat)
{
  // SYNTAX
  //   name | name ( stuff ... )
  // name has already been read in and next token read into tsrc.
  PTREE_NODE *result;
  if (TK_L_ROUND_BRACK != tsrc->tk.type) {
    // name only - bare symbol
    result = ptree_alloc(PT_SYMBOL);
    result->sym = name;
  } else {
    // name (stuff ... )
    push_nest_info(tsrc, ")");
    // skip '('
    tsrc_next(tsrc);
    if (in_pat) {
      result = ptree_alloc(PT_PATTERN_DATA_CONSTRUCTOR);
      if (TK_R_ROUND_BRACK == tsrc->tk.type) {
        // ')' will be skipped below.
        result->ds_pat = ptree_alloc(PT_NULL);
      } else if (!(result->ds_pat = pattern(tsrc, err))) {
        ptree_free(result);
        return NULL;
      }
    } else {
      result = ptree_alloc(PT_DATA_CONSTRUCTOR);
      if (TK_R_ROUND_BRACK == tsrc->tk.type) {
        // ')' will be skipped below.
        result->tup_expr = ptree_alloc(PT_NULL);
      } else if (!(result->tup_expr = tuple_expr(tsrc, err))) {
        ptree_free(result);
        return NULL;
      }
    }
    result->tag = name;
    if (TK_R_ROUND_BRACK != tsrc->tk.type) {
      err->msg = parse_err_msg("Missing closing ')' for data constructor.",
                               tsrc);
      ptree_free(result);
      return NULL;
    }
    pop_nest_info(tsrc);
    // skip ')'
    tsrc_next(tsrc);
  }
  return result;
}

static PTREE_NODE *factor(TOKEN_SOURCE *tsrc, ERR_INFO *err)
{
  // SYNTAX
  //   factor = (
  //             number| symbol | dataConstructor |
  //             closure | varName |'(' [seqExpr] ')'
  //            ) ['(' [tupleExpr] ')' ]
  //   dataConstuctor = symbol '(' [tupleExpr] ')'
  PTREE_NODE *result0 = ptree_alloc(PT_FACTOR),
    *result = ptree_alloc(PT_FACTOR);
  char *name;
  switch (tsrc->tk.type) {
    case TK_L_CLOSURE_BRACK:
      if (!(result0->factor = closure(tsrc, err))) {
        ptree_free(result0);
        ptree_free(result);
        return NULL;
      }
      break;
    case TK_L_ROUND_BRACK:
      push_nest_info(tsrc, ")");
      // skip '('
      tsrc_next(tsrc);
      if (TK_R_ROUND_BRACK == tsrc->tk.type) {
        // '()' is taken as NULL
        result0->factor = ptree_alloc(PT_NULL);
        pop_nest_info(tsrc);
        // skip ')'
        tsrc_next(tsrc);
      } else {
        if (!(result0->factor = seq_expr(tsrc, err))) {
          ptree_free(result0);
          free(result);
          return NULL;
        }
        if (TK_R_ROUND_BRACK != tsrc->tk.type) {
          err->msg = parse_err_msg("Missing closing ')'.", tsrc);
          ptree_free(result0);
          free(result);
          return NULL;
        }
        pop_nest_info(tsrc);
        // Skip ')'
        tsrc_next(tsrc);
      }
      break;
    case TK_NUMBER:
      result0->factor = ptree_alloc(PT_NUMBER);
      result0->factor->num = tsrc->tk.num;
      tsrc_next(tsrc);
      break;
    case TK_NULL:
      result0->factor = ptree_alloc(PT_NULL);
      tsrc_next(tsrc);
      break;
    case TK_SYMBOL:
      name = strdup(tsrc->tk.name);
      tsrc_next(tsrc);
      if (!(result0->factor = get_symbol_or_data_cons(tsrc, err, name, 0))) {
        ptree_free(result);
        ptree_free(result0);
        return NULL;
      }
      break;
    case TK_VARNAME:
      result0->factor = ptree_alloc(PT_VAR_NAME);
      result0->factor->var_name = strdup(tsrc->tk.name);
      tsrc_next(tsrc);
      break;
    default:
      err->msg = parse_err_msg("Unexpected token found for factor.", tsrc);
      free(result);
      return NULL;
      break;
  }
  if (TK_L_ROUND_BRACK != tsrc->tk.type) {
    // Not a function application since we dont have a '(' after
    // a factor.  Keep this token (let it bounce back up to caller) and
    // just return what we've found so far.
    result = result0;
  } else {
    result->factor = ptree_alloc(PT_APPLICATION);
    result->factor->fn = result0;
    result->factor->tup_args = NULL;
    push_nest_info(tsrc, ")");
    // Skip '('
    tsrc_next(tsrc);
    if (TK_R_ROUND_BRACK == tsrc->tk.type) {
      // '()' is taken as NULL
      pop_nest_info(tsrc);
      // Skip ')'
      tsrc_next(tsrc);
      result->factor->tup_args = ptree_alloc(PT_NULL);
    } else {
      if (!(result->factor->tup_args = tuple_expr(tsrc, err))) {
        ptree_free(result);
        return NULL;
      }
      if (TK_R_ROUND_BRACK != tsrc->tk.type) {
        err->msg = parse_err_msg("Missing closing ')' in function application.",
                                 tsrc);
        ptree_free(result->factor->fn);
        ptree_free(result->factor->tup_args);
        ptree_free(result);
        return NULL;
      }
      pop_nest_info(tsrc);
      // Skip ')'
      tsrc_next(tsrc);
    }
  }
  return result;
}

// Helper function to spit out out a parse tree to a graphviz file.
static void ptree_lst_to_gviz_aux(PTREE_NODE_OP_LST *lst_nd, FILE *fout)
{
  char tk_op_str[513];
  TOKEN tdum;
  while (lst_nd) {
    tdum.type = lst_nd->tk_op;
    tk_str(&tdum, tk_op_str, 512);
    fprintf(fout, "  N%p [shape=record,color=blue,label=\"{%s|{<opnd>operand"
            "|<next>next}}\"];\n", lst_nd, tk_op_str);
    fprintf(fout, "  N%p:opnd -> N%p; // operand\n",lst_nd, lst_nd->opnd);
    ptree_to_gviz_aux(lst_nd->opnd, fout);
    if (lst_nd->next) {
      fprintf(fout, "  N%p:next -> N%p [style=dotted, color=blue]; // next\n", lst_nd,
              lst_nd->next);
    }
    lst_nd = lst_nd->next;
  }
}

// Helper function to spit out out a parse tree to a graphviz file.
static void ptree_to_gviz_aux(PTREE_NODE *ptree, FILE *fout)
{
  switch (ptree->type) {
    case PT_NUMBER:
      fprintf(fout, "  N%p [shape=rectangle, color=red"
              ",label =\"PT_NUMBER: %lf\"];\n", ptree, ptree->num);
      break;
    case PT_SEQ_EXPR:
      fprintf(fout, "  N%p [shape=record, label = \"{PT_SEQ_EXPR"
              "|{<expr0> expr0|<rest_seq> rest_seq}}\"];\n", ptree);
      ptree_to_gviz_aux(ptree->expr0, fout);
      fprintf(fout, "  N%p:expr0 -> N%p;\n", ptree, ptree->expr0);
      if (ptree->rest_seq) {
        fprintf(fout, "  N%p:rest_seq -> N%p [style=dotted, color=blue];\n", ptree,
                ptree->rest_seq);
        ptree_lst_to_gviz_aux(ptree->rest_seq, fout);
      }
      break;
    case PT_EXPR:
      fprintf(fout, "  N%p -> N%p;\n", ptree, ptree->expr);
      fprintf(fout, "  N%p [shape=rectangle, label=\"PT_EXPR\"];\n", ptree);
      ptree_to_gviz_aux(ptree->expr, fout);
      break;
    case PT_TUPLE_EXPR:
      fprintf(fout, "  N%p [shape=record, label=\"{PT_TUPLE_EXPR|"
              "{<comp0>comp0|<restcomp>rest_comp}}\"];\n",
              ptree);
      fprintf(fout, "  N%p:comp0 -> N%p;\n", ptree, ptree->comp0);
      ptree_to_gviz_aux(ptree->comp0, fout);
      if (ptree->rest_comp) {
        fprintf(fout, "  N%p:restcomp -> N%p [style=dotted, color=blue];\n", ptree,
                ptree->rest_comp);
        ptree_lst_to_gviz_aux(ptree->rest_comp, fout);
      }
      break;
    case PT_TUPLE_COMPONENT:
      fprintf(fout, "  N%p [shape=record, label=\"{PT_TUPLE_COMPONENT|"
              "{<factor0>factor0|<restfactor>rest_factor}}\"];\n",
              ptree);
      fprintf(fout, "  N%p:factor0 -> N%p;\n", ptree, ptree->factor0);
      ptree_to_gviz_aux(ptree->factor0, fout);
      if (ptree->rest_factor) {
        fprintf(fout, "  N%p:restfactor -> N%p [style=dotted, color=blue];\n", ptree,
                ptree->rest_factor);
        ptree_lst_to_gviz_aux(ptree->rest_factor, fout);
      }
      break;
    case PT_IF_EXPR:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_IF_EXPR|{<test> test|"
              "<then> then-part|<else> else-part}}\"];\n", ptree);
      fprintf(fout, "  N%p:test -> N%p;\n", ptree, ptree->test);
      fprintf(fout, "  N%p:then -> N%p;\n", ptree, ptree->then_part);
      fprintf(fout, "  N%p:else -> N%p;\n", ptree, ptree->else_part);
      ptree_to_gviz_aux(ptree->test, fout);
      ptree_to_gviz_aux(ptree->then_part, fout);
      ptree_to_gviz_aux(ptree->else_part, fout);
      break;
    case PT_FACTOR:
      fprintf(fout, "  N%p -> N%p;\n", ptree, ptree->factor);
      fprintf(fout, "  N%p [shape=rectangle, label=\"PT_FACTOR\"];\n",
              ptree);
      ptree_to_gviz_aux(ptree->factor, fout);
      break;
    case PT_APPLICATION:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_APPLICATION|{<fn> fn|"
              "<tup_args> tup-args}}\"];\n", ptree);
      fprintf(fout, "  N%p:fn -> N%p;\n", ptree, ptree->fn);
      fprintf(fout, "  N%p:tup_args -> N%p;\n", ptree, ptree->tup_args);
      ptree_to_gviz_aux(ptree->fn, fout);
      ptree_to_gviz_aux(ptree->tup_args, fout);
      break;
    case PT_SYMBOL:
      fprintf(fout, "  N%p [shape=rectangle,color=red,label=\"PT_SYMBOL:"
              " %s\"];\n", ptree, ptree->sym);
      break;
    case PT_DATA_CONSTRUCTOR:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_DATA_CONSTRUCTOR|"
              "{tag=%s|<tup_expr> tup_expr}}\"];\n", ptree, ptree->tag);
      fprintf(fout, "  N%p:tup_expr -> N%p;\n", ptree, ptree->tup_expr);
      ptree_to_gviz_aux(ptree->tup_expr, fout);
      break;
    case PT_VAR_NAME:
      fprintf(fout, "  N%p [shape=rectangle,color=red,label=\"PT_VAR_NAME: %s\"];\n",
              ptree, ptree->var_name);
      break;
    case PT_NULL:
      fprintf(fout, "  N%p [shape=rectangle,color=red,label=\"PT_NULL\"];\n",
              ptree);
      break;
    case PT_CLOSURE:
      fprintf(fout, "  N%p [shape=record, color=red,label=\"{PT_CLOSURE|"
              "{<patalt>pat_alt|<restpatalts>rest_pat_alts}}\"];\n", ptree);
      if (ptree->pat_alt0) {
        fprintf(fout, "  N%p:patalt -> N%p;\n", ptree, ptree->pat_alt0);
        ptree_to_gviz_aux(ptree->pat_alt0, fout);
      }
      if (ptree->rest_pat_alts) {
        fprintf(fout, "  N%p:restpatalts -> N%p [style=dotted, color=blue];\n", ptree,
                ptree->rest_pat_alts);
        ptree_lst_to_gviz_aux(ptree->rest_pat_alts, fout);
      }
      break;
    case PT_PATTERN_ALTERNATIVE:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_PATTERN_ALTERNATIVE|"
              "{<pat> pat|<resseqexp>result_seq_expr}}\"];\n", ptree);
      fprintf(fout, "  N%p:resseqexp -> N%p;\n", ptree, ptree->result_seq_expr);
      if (ptree->pat) {
        fprintf(fout, "  N%p:pat -> N%p;\n", ptree, ptree->pat);
        ptree_to_gviz_aux(ptree->pat, fout);
      }
      ptree_to_gviz_aux(ptree->result_seq_expr, fout);
      break;
    case PT_ANONYMOUS_VAR:
      fprintf(fout, "  N%p [shape=rectangle,color=green,"
              "label=\"PT_ANONYMOUS_VAR\"];\n", ptree);
      break;
    case PT_PATTERN:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_PATTERN|"
              "{<tuppatcmp>tup_pat_cmp0|<rsttuppatcmp>rest_tup_pat_cmp}}\"];\n",
              ptree);
      fprintf(fout, "  N%p:tuppatcmp -> N%p;\n", ptree, ptree->tup_pat_cmp0);
      ptree_to_gviz_aux(ptree->tup_pat_cmp0, fout);
      if (ptree->rest_tup_pat_cmp) {
        fprintf(fout, "  N%p:rsttuppatcmp -> N%p [style=dotted, color=blue];\n", ptree,
                ptree->rest_tup_pat_cmp);
        ptree_lst_to_gviz_aux(ptree->rest_tup_pat_cmp, fout);
      }
      break;
    case PT_TUPLE_PATTERN_COMPONENT:
      fprintf(fout, "  N%p [shape=rectangle,label="
              "\"PT_TUPLE_PATTERN_COMPONENT\"];\n", ptree);
      fprintf(fout, "  N%p -> N%p;\n", ptree, ptree->tup_pat_cmp);
      ptree_to_gviz_aux(ptree->tup_pat_cmp, fout);
      break;
    case PT_PATTERN_VAR:
      fprintf(fout, "  N%p [shape=rectangle,color=green,label=\"PT_PATTERN_VAR:"
              "%s\"];\n", ptree, ptree->pat_var);
      break;
    case PT_TEST:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_TEST|"
              "{test_name=%s|<testpat>test_pat}}\"];\n", ptree,
              ptree->test_name);
      if (ptree->test_pat) {
        fprintf(fout, "  N%p:testpat -> N%p;\n", ptree, ptree->test_pat);
        ptree_to_gviz_aux(ptree->test_pat, fout);
      }
      break;
    case PT_PATTERN_DATA_CONSTRUCTOR:
      fprintf(fout, "  N%p [shape=record,label=\"{PT_PATTERN_DATA_CONSTRUCTOR|"
              "{tag=%s|<ds_pat>ds_pat}}\"];\n", ptree, ptree->tag);
      fprintf(fout, "  N%p:ds_pat -> N%p;\n", ptree, ptree->ds_pat);
      ptree_to_gviz_aux(ptree->ds_pat, fout);
      break;
    case PT_VAR_REF:
      fprintf(fout, "  N%p [shape=rectangle,color=green,label=\"PT_VAR_REF:"
              "%s\"];\n", ptree, ptree->ref_var);
      break;
    default:
      fprintf(fout, "  N%p [label =\"unknown type: %d\"];\n", ptree, ptree->type);
      break;
  }
}

// Spit out a parse tree to a graphviz file.
void ptree_to_gviz(PTREE_NODE *ptree, char *fname)
{
  FILE *fout = fopen(fname, "w");
  if (!fout) {
    fprintf(stderr, "Unable to open %s for output.\n", fname);
    exit(0);
  }
  fprintf(fout, "digraph parsetree {\n");
  ptree_to_gviz_aux(ptree, fout);
  fprintf(fout, "}\n");
  fclose(fout);
}

#ifdef TEST_PTREE

static void init_gr(char test_type, char *arg, GEN_READ *r)
{
  switch (test_type) {
    case 'f':
      if (!gr_open_file(r, arg)) {
        fprintf(stderr, "Can't open %s\n", arg);
        exit(0);
      }
      break;
    case 's':
      if (!gr_open_str(r, arg)) {
        fprintf(stderr, "Can't initialize with string.\n");
        exit(0);
      }
      break;
    case 'r':
      if (!gr_open_rdln(r, arg)) {
        fprintf(stderr, "Can't initialize with readline.\n");
        exit(0);
      }
      prompt = strdup(arg);
      break;
    default:
      fprintf(stderr, "Unrecognized input type: %c\n", test_type);
      exit(0);
      break;
  }
}

void main(int argc, char **argv)
{
  if (argc == 3) {
    GEN_READ r;
    char fname[100];
    int i = 0;
    PTREE_NODE *ptree;
    ERR_INFO err;
    init_gr(*argv[1], argv[2], &r);
    while (!gr_eof(&r)) {
      ptree = parse(&r, &err);
      if (!ptree) {
        if (err.msg) {
          printf("*Error %s\n", err.msg);
          exit(0);
        }
      } else {
        sprintf(fname, "pt%d.dot", i++);
        ptree_to_gviz(ptree, fname);
        printf("parse tree written to %s\n", fname);
      }
    }
    printf("done.\n");
  } else {
    printf("args: (f <file> | s <string> | r <prompt>)\n");
  }
}
#endif
